PC Answers 1995 May

home *** CD-ROM | disk | FTP | other *** search

/ PC Answers 1995 May / PC Answers CD-ROM 7 (Future Publishing) (May 1995).iso / vbits / code / mee / vbdao / visdata / opendb.frm (.txt) < prev next >

Wrap

Visual Basic Form | 1994-10-06 | 10.3 KB | 338 lines

VERSION 2.00 Begin Form fOpenDB BackColor = &H00C0C0C0& BorderStyle = 1 'Fixed Single Caption = "Open DataBase" ClientHeight = 2160 ClientLeft = 2460 ClientTop = 3840 ClientWidth = 4395 ControlBox = 0 'False ForeColor = &H00C0C0C0& Height = 2565 Left = 2400 LinkTopic = "Form2" MaxButton = 0 'False MinButton = 0 'False ScaleHeight = 2119.728 ScaleMode = 0 'User ScaleWidth = 4447.083 Top = 3495 Width = 4515 Begin ComboBox cDBName BackColor = &H00FFFFFF& Height = 300 Left = 1680 Sorted = -1 'True TabIndex = 0 Tag = "OLS" Top = 105 Width = 2655 End Begin TextBox cDataBase BackColor = &H00FFFFFF& Height = 285 Left = 1680 TabIndex = 1 Tag = "OLS" Top = 465 Width = 2655 End Begin TextBox cUserName BackColor = &H00FFFFFF& Height = 285 Left = 1680 TabIndex = 2 Tag = "OLS" Top = 825 Width = 2655 End Begin TextBox cPassword BackColor = &H00FFFFFF& Height = 285 Left = 1680 PasswordChar = "*" TabIndex = 3 Tag = "OLS" Top = 1185 Width = 2655 End Begin CommandButton OkayButton BackColor = &H00C0C0C0& Caption = "&Open" Default = -1 'True Height = 375 Left = 300 TabIndex = 4 Top = 1680 Width = 1575 End Begin CommandButton CancelButton BackColor = &H00C0C0C0& Cancel = -1 'True Caption = "&Cancel" Height = 375 Left = 2460 TabIndex = 5 Top = 1680 Width = 1575 End Begin Label Label1 BackColor = &H00C0C0C0& Height = 495 Left = 4080 TabIndex = 10 Top = 1680 Width = 375 End Begin Label DataBaseLabel BackColor = &H00C0C0C0& Caption = "DataBase:" Height = 255 Left = 120 TabIndex = 9 Top = 465 Width = 1335 End Begin Label DBNameLabel BackColor = &H00C0C0C0& Caption = "Source/Server:" Height = 255 Left = 120 TabIndex = 6 Top = 105 Width = 1470 End Begin Label UserNameLabel BackColor = &H00C0C0C0& Caption = "User ID:" Height = 255 Left = 120 TabIndex = 7 Top = 825 Width = 1335 End Begin Label PasswordLabel BackColor = &H00C0C0C0& Caption = "Password:" Height = 255 Left = 120 TabIndex = 8 Top = 1170 Width = 1335 End Option Explicit Dim BeenLoaded As Integer Sub CancelButton_Click () gfDBOpenFlag = False gstDBName = NULL_STR gstDataBase = NULL_STR gstUserName = NULL_STR gstPassword = NULL_STR Unload Me End Sub Sub cDBName_Click () On Error Resume Next Dim tmp As String Dim x As Integer cDatabase = NULL_STR cUserName = NULL_STR cPassword = NULL_STR 'get the database name if there is one tmp = String$(255, 32) x = OSGetPrivateProfileString(cDBName, "database", NULL_STR, tmp, Len(tmp), "ODBC.INI") cDatabase = Mid$(tmp, 1, x) 'get the last user name is there is one tmp = String$(255, 32) x = OSGetPrivateProfileString(cDBName, "lastuser", NULL_STR, tmp, Len(tmp), "ODBC.INI") cUserName = Mid$(tmp, 1, x) cPassword = NULL_STR If Len(cUserName) > 0 Then cPassword.SetFocus Else cDatabase.SetFocus End If End Sub Sub Form_Load () Left = (Screen.Width - Width) / 2 Top = (Screen.Height - Height) / 2 GetDataSources cDBName cDBName = gstDBName cDatabase = gstDataBase cUserName = gstUserName cPassword = gstPassword MsgBar "Enter DataBase Parameters", False BeenLoaded = True End Sub Sub Form_Paint () Outlines Me End Sub Sub Form_Unload (Cancel As Integer) MsgBar NULL_STR, False End Sub 'this routine fills a list box with all available 'ODBC data sources found in ODBC.INI Sub GetDataSources (listctrl As Control) Dim DataSource As String, Description As String Dim DataSourceLen As Integer, DescriptionLen As Integer Dim retcode As Integer Dim henv As Long If SQLAllocEnv(henv) <> -1 Then DataSource = String$(32, 32) Description = String$(255, 32) 'get the first one retcode = SQLDataSources(henv, 2, DataSource, Len(DataSource), DataSourceLen, Description, Len(Description), DescriptionLen) While retcode = 0 Or retcode = 1 listctrl.AddItem Mid(DataSource, 1, DataSourceLen) DataSource = String$(32, 32) Description = String$(255, 32) 'get all the others retcode = SQLDataSources(henv, 1, DataSource, Len(DataSource), DataSourceLen, Description, Len(Description), DescriptionLen) Wend End If End Sub Sub Label1_DblClick () If Len(Label1) = 0 Then Label1 = "E" Else Label1 = NULL_STR End If End Sub Sub OkayButton_Click () Dim Connect As String, DataSource As String Dim x As Integer Dim st As String Dim i As Integer Dim s As String, t As String Dim dbq As String On Error GoTo OpenError MsgBar "Opening DataBase", True If VDMDI.PrefOpenOnStartup.Checked = True Then Me.Refresh End If SetHourglass Me 'check for blank server name and clear other parms If Len(cDBName) = 0 Then cDatabase = NULL_STR cUserName = NULL_STR cPassword = NULL_STR End If 'build connect string Connect = "ODBC;" If Len(cUserName) > 0 Then Connect = Connect & "UID=" & cUserName & ";PWD=" & cPassword End If If Len(cDatabase) > 0 Then Connect = Connect & ";DATABASE=" & cDatabase End If 'add login timeout Connect = Connect & ";LoginTimeout=" & glLoginTimeout If Label1 = "E" Then Connect = Connect & ";APP=Einstein" DataSource = cDBName 'save the values gstDBName = cDBName gstDataBase = cDatabase gstUserName = cUserName gstPassword = cPassword gstDataType = SQLDB Me.Hide Set gCurrentDB = OpenDatabase(DataSource, False, False, Connect) If gfDBOpenFlag = True Then CloseAllDynasets End If gfTransPending = False VDMDI.ToolBar.Visible = True VDMDI.QueryBuilder.Visible = True VDMDI.TblAttach.Visible = False fSQL.CreateQueryDefbtn.Visible = False 'process the connect string just in case the 'values came from the ODBC dialogs t = gCurrentDB.Connect If InStr(t, "=") Then i = 1 While i <= Len(t) + 1 If Mid(t, i, 1) = ";" Or i = Len(t) + 1 Then If Len(s) > 0 And InStr(s, "=") > 0 Then Select Case Mid(s, 1, InStr(1, s, "=") - 1) Case "DSN" gstDBName = Mid(s, InStr(1, s, "=") + 1, Len(s)) Case "DATABASE" gstDataBase = Mid(s, InStr(1, s, "=") + 1, Len(s)) Case "DBQ" gstDataBase = Mid(s, InStr(1, s, "=") + 1, Len(s)) Case "UID" gstUserName = Mid(s, InStr(1, s, "=") + 1, Len(s)) Case "PWD" gstPassword = Mid(s, InStr(1, s, "=") + 1, Len(s)) Case Else 'nothing End Select End If s = NULL_STR Else s = s + Mid(t, i, 1) End If i = i + 1 Wend End If cDBName = gstDBName cDatabase = gstDataBase cUserName = gstUserName cPassword = gstPassword x = OSWritePrivateProfileString(gstDBName, "Database", gstDataBase, "ODBC.INI") x = OSWritePrivateProfileString(gstDBName, "LastUser", gstUserName, "ODBC.INI") fTables.Caption = gstDBName & "." & gstDataBase gCurrentDB.QueryTimeout = glQueryTimeout 'success gfDBOpenFlag = True ResetMouse Me Unload Me GoTo OkayEnd OpenError: ResetMouse Me gfDBOpenFlag = False If Len(cDBName) > 0 Then If InStr(1, Error$, "Data source not found") > 0 Then Beep MsgBox "This DataBase has not been Registered, this will now be attempted for you!", 48 cDatabase = NULL_STR cUserName = NULL_STR cPassword = NULL_STR If RegisterDB((cDBName)) = True Then MsgBox "'" & cDBName & "' has been Registered, proceed with Open.", 48 End If ElseIf InStr(1, Error$, "Login failed") > 0 Then Beep MsgBox "Invalid Parameter(s), Please try again!", 48 ElseIf InStr(1, Error$, "QueryTimeout property") > 0 Then If glQueryTimeout <> 5 Then Beep MsgBox "Query Timeout Could not be set, default will be used!", 48 End If Resume Next Else ShowError End If End If MsgBar "Enter DataBase Parameters", False Me.Show MODAL Resume OkayEnd OkayEnd: End Sub Function RegisterDB (dbname As String) As Integer On Error GoTo RDBErr Dim driver As String driver = InputBox("Enter Driver Name from ODBCINST.INI File:", "Driver Name", DEFAULTDRIVER) If driver <> DEFAULTDRIVER Then RegisterDatabase cDBName, driver, False, NULL_STR Else RegisterDatabase cDBName, driver, True, NULL_STR End If RegisterDB = True GoTo RDBEnd RDBErr: RegisterDB = False Resume RDBEnd RDBEnd: End Function